home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PAS_0793 / SERIAL.PAS < prev    next >
Pascal/Delphi Source File  |  1993-08-01  |  6KB  |  169 lines
  1. (*─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 274 of 284                                                               
  3. From : Ethan Brodsky                       1:121/8.0            06 Jul 93  22:14 
  4. To   : Ben Curtis                                                                
  5. Subj : Serial number of disk                                                  
  6. ────────────────────────────────────────────────────────────────────────────────
  7. >  * Ethan Brodsky was talking all about Serial Number of disk to Mike
  8. > Copeland *
  9. >
  10. >  EB> Sorry, my time ran out between messages.   Here is the rest of
  11. > the  EB> serial number program.   My comm package mighta screwed up
  12. > the spacing
  13. >  EB> and stuff pasting it into this message.
  14. >  EB> {-----------------------------Cut
  15. > Here----------------------------}
  16. >
  17. >         Could you please repost both parts, as I missed the first one
  18. > and
  19. > your second one was pretty messed up by the time it got here.  Tnx...
  20. >
  21. >
  22. >
  23. Ok, here goes!
  24. ---------------------Cut here - SERIAL.PAS---------------------------*)
  25. program Serial(input, output);
  26.  
  27. const
  28.         HexDigits: array[0..15] of char = '0123456789ABCDEF';
  29. type
  30.         InfoBuffer = record
  31.                 InfoLevel       : word;  {should be zero}
  32.                 Serial          : longint;
  33.                 VolLabel        : array[0..10] of Char;
  34.                 FileSystem      : array[0..7] of Char;
  35.         end;
  36.         SerString = String[9];
  37.  
  38. var
  39.         IB        : InfoBuffer;
  40.         N         : word;
  41.         let       : char;
  42.         param     : string[10];
  43.         IsSet     : boolean;
  44.         NewSerial : longint;
  45.         code      : integer;
  46.  
  47.         function SerialStr(L : longint) : SerString;
  48.         var Temp : SerString;
  49.         begin
  50.                 Temp[0] := #9;
  51.                 Temp[1] := HexDigits[L shr 28];
  52.                 Temp[2] := HexDigits[(L shr 24) and $F];
  53.                 Temp[3] := HexDigits[(L shr 20) and $F];
  54.                 Temp[4] := HexDigits[(L shr 16) and $F];
  55.                 Temp[5] := '-';
  56.                 Temp[6] := HexDigits[(L shr 12) and $F];
  57.                 Temp[7] := HexDigits[(L shr 8) and $F];
  58.                 Temp[8] := HexDigits[(L shr 4) and $F];
  59.                 Temp[9] := HexDigits[L and $F];
  60.                 SerialStr :=Temp;
  61.         end;
  62.  
  63.         function GetSerial(DiskNum : byte;
  64.                 var I : InfoBuffer) : word; assembler;
  65.         asm
  66.                 MOV AH, 69h
  67.                 MOV AL, 00h
  68.                 MOV BL, DiskNum
  69.                 PUSH DS
  70.                 LDS DX, I
  71.                 INT 21h
  72.                 POP DS
  73.                 JC @Bad
  74.                 XOR AX, AX
  75.                 @Bad:
  76.         end;
  77.  
  78.         function SetSerial(DiskNum : byte;
  79.                 var I : InfoBuffer) : word; Assembler;
  80.         asm
  81.                 MOV AH, 69h
  82.                 MOV AL, 00h
  83.                 MOV BL, DiskNum
  84.                 PUSH DS
  85.                 LDS DX, I
  86.                 INT 21h
  87.                 POP DS
  88.                 JC @Bad
  89.                 XOR AX, AX
  90.                 @Bad:
  91.         end;
  92.  
  93.         procedure ErrorOut(err : Byte);
  94.         begin
  95.                 case err of
  96.                         5   : begin
  97.                                 writeln('Either the disk in ',let,': is
  98. write-',
  99.                                         'protected or it lacks an
  100. extended BPB.');
  101.                                 writeln('If the disk is not
  102. write-protected, ',
  103.                                         'reformat it with DOS 4 or
  104. higher.');
  105.                               end;
  106.                         15  : writeln('Not a valid drive letter.');
  107.                         255 : begin
  108.                                 writeln('SYNTAX:   SERIAL D:
  109. ########"');
  110.                                 writeln('  where D: is the drive letter
  111. ',
  112.                                         'and ######## is the eight
  113. digit');
  114.                                 writeln('  hexadecimal serial number
  115. with-',
  116.                                         'out the "-".');
  117.                                 writeln('EXAMPLE:  SERIAL A: 1234ABCD');
  118.                               end;
  119.                         else writeln('DOS ERROR #',N);
  120.                 end;
  121.                 halt(1);
  122.         end;
  123.  
  124. begin
  125.         if ParamCount < 1 then ErrorOut(255);
  126.         if ParamCount > 2 then ErrorOut(255);
  127.         Param := ParamStr(1);
  128.         case length(Param) of
  129.           1 : {OK};
  130.           2 : if Param[2] <> ':' then ErrorOut(255);
  131.           else ErrorOut(255);
  132.         end;
  133.         let := upcase(Param[1]);
  134.         if (let < 'A') or (let > 'Z') Then ErrorOut(15);
  135.         if ParamCount < 2 then IsSet := false
  136.         else
  137.                 begin
  138.                         IsSet := true;
  139.                         Param:= '$'+ParamStr(2);
  140.                         Val(Param, NewSerial, Code);
  141.                         if Code <> 0 then ErrorOut(255);
  142.                 end;
  143.         N := GetSerial(ord(Let)-ord('@'), IB);
  144.         if N = 0 then
  145.                 begin
  146.                         with IB do
  147.                                 begin
  148.                                         writeln('Serial Number is "',
  149. SerialStr(Serial), '"');
  150.                                          if IsSet then
  151.                                                 begin
  152.                                                         Serial :=
  153. NewSerial;;
  154.                                                        N :=
  155. SetSerial(ord(Let)-ord('@'), IB);
  156.                                                         if N = 0 then
  157.  
  158. writeln('Successfully canged serial to "',
  159.  
  160. Seri
  161.     alStr(NewSerial),'"')
  162.                                                                  else
  163. ErrorOut(N);
  164.                                                 end;
  165.                                 end;
  166.                 end
  167.                 else ErrorOut(N);
  168.  
  169. end.